;;;
;;; random access lists 
;;;

(define-module lib-rlist-skew

	(export 
		rcons  ; O(1), (rcons a rl) -> rl'
		rcar   ; O(1), (rcar (rcons a rl)) -> a
		rcdr   ; O(1), (rcdr (rcons a rl)) -> rl'*
		rnull? ; O(1), plain null?
		rlist? ; O(1), obj -> bool
		rget   ; O(log n), (rget rl pos def) -> val | def if outside of rl
		rset   ; O(log n), (rset rl pos val) -> rl' | error if outside of rl
		rlen   ; O(log n)
		rfold	 ; O(n), like fold
		rfoldr ; O(n), like foldr
		rmap	 ; O(n), like map
		riter	 ; O(n), rlist -> lazy list (aka iterator) **
		riterr ; O(n), ditto backwards 
		requal?     ; O(n)***
		rlist->list ; O(n)
		list->rlist ; O(n log n), temp
		rlist			; (rlist ...) -> rl
		render
		) 
		
		; *   (equal? rl rl') = True, but not necessarily (eq? rl rl')
		; **  you can therefore use all lib-lazy list functions
		; *** normal equal? will do because the representation is unique

	; note, taken primitive type 10 for spines, variant 42 for nodes
	; ie cannot store a node of type 42 into a rlist (which would be a 
	; major abstraction violation anyway).

	(define rnull? null?)

	(define (rlist? l)
		(cond
			((null? l) True)
			((teq? l (alloc 10)) True) 
			(else False)))

	;; consructors, later autogenerated 

	(define-syntax node
		(syntax-rules ()
			((node a l r) (mkt 42 a l r))))

	(define-syntax if-node
		(syntax-rules (teq? alloc)
			((if-node val a b)
				(if (teq? val (alloc 42)) a b))))

	(define-syntax spine
		(syntax-rules ()
			((spine w t rl) (mkt 10 w t rl))))

	;; cons 

	(define (rcons a rl)
		(if (null? rl)
			(spine 1 a rl)
			(lets ((w1 t1 tl rl))
				(if (null? tl)
					(spine 1 a rl)
					(lets ((w2 t2 ttl tl))
						(if (= w1 w2)
							(spine (+ (+ w1 w2) 1) (node a t1 t2) ttl)
							(spine 1 a rl)))))))

	;; car & cdr 

	(define (rcar rl) 
		(lets ((w a tl rl))
			(if-node a (ref a 1) a)))

	(define (rcdr rl)
		(lets ((w n tl rl))
			(if-node n
				(lets ((x a b n) (w (>> w 1)))
					(spine w a (spine w b tl)))
				tl)))

	;; get 

	(define (rget-tree n w p)
		(if (eq? p 0) 
			(if-node n (ref n 1) n)
			(lets ((a t1 t2 n) (wp (>> w 1)))
				(if (<= p wp)
					(rget-tree t1 wp (- p 1))
					(rget-tree t2 wp (- p (+ wp 1)))))))

	(define (rget rl pos def)
		(if (null? rl) 
			def
			(lets ((w t tl rl))
				(if (< pos w)
					(rget-tree t w pos)
					(rget tl (- pos w) def)))))

	;; set 

	(define (rset-tree n w p v)
		(if (eq? p 0) 
			(if-node n (set n 1 v) v)
			(lets ((a t1 t2 n) (wp (>> w 1)))
				(if (<= p wp)
					(set n 2 (rset-tree t1 wp (- p 1) v))
					(set n 3 (rset-tree t2 wp (- p (+ wp 1)) v))))))

	(define (rset rl pos val)
		(if (null? rl) 
			(error "rset: out of list setting " val)
			(lets ((w t tl rl))
				(if (< pos w)
					(spine w (rset-tree t w pos val) tl)
					(spine w t (rset tl (- pos w) val))))))

	;; map

	(define (rmap-tree n op)
		(if-node n
			(lets ((a t1 t2 n))
				(node (op a) 
					(rmap-tree t1 op)
					(rmap-tree t2 op)))
			(op n)))

	(define (rmap op rl)
		(if (null? rl)
			null
			(lets ((w t tl rl))
				(spine w (rmap-tree t op) (rmap op tl)))))

	;; riter (forwards)

	; note, this generates (log t) of tree size t in one run 
	; to reduce the overhead. insert a lambda after the cons 
	; to get just one at a time.

	(define (riter-tree n tail)
		(if-node n
			(lets ((a t1 t2 n))
				(cons a
					(riter-tree t1
						(lambda () (riter-tree t2 tail)))))
			(cons n tail)))

	(define (riterator rl tail)
		(if (null? rl)
			tail
			(lets ((w t tl rl))
				(riter-tree t 
					(lambda () (riterator tl tail))))))

	(define (riter rl) (riterator rl null))

	;; riterr (backwards)

	(define (riterr-tree n tail)
		(if-node n
			(lets ((a t1 t2 n) (tail (cons a tail)))
				(riterr-tree t2
					(lambda ()
						(riterr-tree t1 tail))))
			(cons n tail)))

	(define (riteratorr rl tail)
		(if (null? rl)
			tail
			(lets ((w t tl rl))
				(riteratorr tl
					(lambda ()
						(riterr-tree t tail))))))

	(define (riterr rl) (riteratorr rl null))

	;; rfold (== (lfold op st (riter rl)))

	(define (rfold-tree op st n)
		(if-node n
			(lets 
				((a t1 t2 n)
				 (st (op st a))
				 (st (rfold-tree op st t1)))
				(rfold-tree op st t2))
			(op st n)))

	(define (rfold op st rl)
		(if (null? rl)
			st
			(lets ((w t tl rl))
				(rfold op (rfold-tree op st t) tl))))

	;; rfoldr (== (lfoldr op st (riterr rl)))

	(define (rfoldr-tree op st n)
		(if-node n
			(lets 
				((a t1 t2 n)
				 (st (rfoldr-tree op st t2))
				 (st (rfoldr-tree op st t1)))
				(op a st))
			(op n st)))

	(define (rfoldr op st rl)
		(if (null? rl)
			st
			(lets ((w t tl rl))
				(rfoldr-tree op (rfoldr op st tl) t))))
	
	;; conversions

	(define (list->rlist l) ; naive O(n log n)
		(foldr rcons null l))

	(define (rlist->list rl)
		(rfoldr cons null rl))

	;; len

	(define (rlen rl)
		(let loop ((rl rl) (l 0))
			(if (null? rl) 
				l
				(lets ((w a tl rl))
					(loop tl (+ l w))))))

	;; comparison

	(define requal? equal?)

	(define-syntax rlist
		(syntax-rules ()
			((rlist) null)
			((rlist a . as) 
				(rcons a (rlist . as)))))

	;; todo: start switching constructors to uppercase syntax at some point
	;; todo: start adding generic extensible parsers, so that (RList 1 2 3 4) can be added here
	(define render
		(lambda (self ob tl)
			(if (teq? ob (alloc 10)) ;; nonempty rlist
				(self self (cons "RList" (rlist->list ob)) tl)
				(render self ob tl))))

)



;;
;; Another attempt.
;;

; make the obvious list of growing complete binary trees, but avoid the need 
; to store numbers to denote their sizes by storing one bit of size information 
; to the type and carefully maintaining a few invariants for the sizes:
;  - the first tree (if any) is always of depth 1
;  - there are at most 2 consecutive trees of the same depth
;  - the depths depth of the next tree is the same as current, or one deeper
; thus, depths (1 1), (1 1 2 3), (1 2 2 3) are ok, while (1 1 1 2), (2 2 4 8) 
; and (1 4) are not. (5) is right out.

(define-module lib-rlist-owl

   (export 
      rcons
      rlist?
      rcar
      rget)

   ;; use type 14
	(define (rlist? l)
		(cond
			((null? l) True)
			((teq? l (alloc 14)) True) 
			((teq? l (alloc 46)) True) 
			(else False)))

	;; constructors

	(define-syntax same
		(syntax-rules ()
			((same a r) (mkt 14 a r))))
	
   (define-syntax less
		(syntax-rules ()
			((less a r) (mkt 46 a r))))
   
   (define-syntax node ;; in-tree node
      (syntax-rules () 
         ((node a b) (mkt 78 a b))))

   ;; these are still not in use. type predicates and constructors later autogenerated.
   (define-syntax same?
      (syntax-rules () ((same? r) (teq? r (alloc 14)))))

   (define-syntax less?
      (syntax-rules () ((less? r) (teq? r (alloc 46)))))

   ; R = () | (less a1 ()) | (less a1 R) | (same a1 R)

   ; a is a value of *same size as head of r* (if any)
   ; O(log n)
   (define (rcons a r)
      (cond
         ((null? r) 
            (less a r))
         ((teq? r (alloc 14))
            (lets ((b rr r))
               (if (null? rr)
                  (less a r)
                  (lets ((c rr rr))
                     (less a (rcons (node b c) rr))))))
         (else
            (same a r))))

   ; O(1)
   (define (rcar r)
      (ref r 1))
   
   ; O(log n)
   '(define (rcdr r) 
      (if (teq? r (alloc 14))  ;; same -> (1 1 ...)
         (ref r 2)             ;; -> (1 ...)
         (lets                 ;; (less 1 ...)
            ((r (ref r 2)))    ;; r = ...
            (if (null? r)      ;; (less 1 ()) -> ()
               r
               (lets ((n r r)) ;; 2 ...
                  (cond
                     ((null? r) ...)))))))

   (define (ref-small-tree r p n)
      (if (eq? n 0) 
         r
         (lets ((n _ (fx>> n 1)))
            (if (eq? (fxband p n) 0)
               (ref-small-tree (ref r 1) p n)
               (ref-small-tree (ref r 2) p n)))))

   (define (ref-tree r p n)
      (cond
         ((eq? n 0) r)
         ((teq? n fix+)
            (if (teq? p fix+)
               (ref-small-tree r p n)
               (ref-small-tree r (ncar p) n)))
         ((eq? (band p n) 0)
            (ref-tree (ref r 1) p (>> n 1)))
         (else
            (ref-tree (ref r 2) p (>> n 1)))))


   ;; rlist pos def → rlist[pos] | def
   (define (rget r p d)
      ;; find the correct tree
      (let loop ((r r) (p p) (n 1))
         (cond
            ((null? r) d)
            ((< p n)
               (if (eq? n 1)
                  (ref r 1)
                  (let ((n (>> n 1)))
                     (if (teq? n fix+)
                        (ref-small-tree (ref r 1) p n)
                        (ref-tree (ref r 1) p n)))))
            ((teq? r (alloc 14))
               (loop (ref r 2) (- p n) n))
            (else
               (loop (ref r 2) (- p n) (<< n 1))))))

   (define (rlen r)
      (let loop ((r r) (s 0) (n 1))
         (cond
            ((null? r) s)
            ((teq? r (alloc 14))
               (loop (ref r 2) (+ s n) n))
            (else
               (loop (ref r 2) (+ s n) (<< n 1))))))

   ;;
   ;; Folds
   ;;

   (define (rfold-tree op st n)
      (if (teq? n (alloc 78)) ;; in-tree node. note, cannot store these in rlists (as in other data structures)
         (rfold-tree op 
            (rfold-tree op st (ref n 1))
            (ref n 2))
         (op st n)))

   ;; O(n)
   (define (rfold op st rl)
      (if (null? rl) 
         st
         (rfold op
            (rfold-tree op st (ref rl 1))
            (ref rl 2))))

   (define (rfoldr-tree op st n)
      (if (teq? n (alloc 78)) ;; in-tree node. note, cannot store these in rlists (as in other data structures)
         (rfoldr-tree op 
            (rfoldr-tree op st (ref n 2))
            (ref n 1))
         (op n st)))

   ;; O(n)
   (define (rfoldr op st rl)
      (if (null? rl) 
         st
         (rfoldr-tree op  
            (rfoldr op st (ref rl 2))
            (ref rl 1))))

   ;;
   ;; Utils
   ;;

   ;; O(n log n)
   (define (rapp ra rb) 
      (rfoldr rcons rb ra))

   ;; O(n log n)
   (define (list->rlist lst) 
      (foldr rcons null lst)) 
   
   ;; O(n)
   (define (rlist->list rl)
      (rfoldr cons null rl))

   '(begin
      (show " => " (fold - 0 (iota 0 1 100)))
      (show " => " (rfold - 0 (foldr rcons null (iota 0 1 100))))
      (show " => " (foldr - 0 (iota 0 1 100)))
      (show " => " (rfoldr - 0 (foldr rcons null (iota 0 1 100))))
      (show " => " (let ((a (iota 0 1 100)) (b (iota 100 1 200))) 
                        (equal? (rlist->list (rapp (list->rlist a) (list->rlist b)))
                                (rlist->list (list->rlist (append a b))))))
      (show " => " (let ((l (iota 0 1 100))) (equal? (length l) (rlen (list->rlist l)))))
      (show " => " (let ((l (iota 0 1 1000))) (equal? (length l) (rlen (list->rlist l)))))
      (show " => " (let ((l (iota 0 1 10000))) (equal? (length l) (rlen (list->rlist l)))))
      )

   (define (rlist->num rl)
      (let loop ((rl rl) (n 1))
         (cond
            ((null? rl) null)
            ((teq? rl (alloc 14))
               (cons n (loop (ref rl 2) n)))
            (else
               (cons n (loop (ref rl 2) (* n 2)))))))

   '(for-each
      (λ (n)
         ;(show " -> " (foldr rcons null (iota 0 1 n)))
         (show " ==> " (rlist->num (foldr rcons null (iota 0 1 n)))))
      (iota 1 1 10))

)

(define lib-rlist lib-rlist-skew)

;(import lib-rlist-owl)
;(import lib-rlist-skew)
;(let ((rl (fold (λ (rl n) (rcons n rl)) null (liota 0 1 100000))))
;   (print "running")
;   (fold (λ (sum n) (rget rl n 42)) 0 (liota 0 1 100000))
;   )

;(import lib-lazy)
;(import lib-rlist)
;(lfoldr (lambda (a b) (cons a b)) null (riterr (list->rlist '(1 2 3 4))))
;(begin (! 1000) (halt 1))


;;;
;;; a bit of testing
;;;
;
;(define-module lib-rlist-test
;
;	(import lib-rlist)
;	;(import lib-random)
;	;(import lib-lazy)
;
;	; lset could be on toplevel
;
;	(define (lset l p v)
;		(if (= p 0)
;			(cons v (cdr l))
;			(cons (car l) (lset (cdr l) (- p 1) v))))
;
;	(define max-list-size 10000)
;
;	; run a battery of operations to a list and an equal rlist
;	; and stop on inconsistencies 
;
;	(define (list-test rst rl l len)
;		(lets ((rst n (rand rst 25)))
;			(case n
;				((0 1 2 3) ; cons a new head
;					(if (< len max-list-size)
;						(lets ((rst x (rand rst 1000)))
;							(list-test rst (rcons x rl) (cons x l) (+ len 1)))
;						(list-test rst rl l len)))
;				((4 5) ; drop a head, slightly less frequent 
;					(if (= len 0)
;						(list-test rst rl l len)
;						(list-test rst (rcdr rl) (cdr l) (- len 1))))
;				((7 8) ; check car
;					(cond
;						((= len 0) (list-test rst rl l len))
;						((eq? (rcar rl) (car l)) (list-test rst rl l len))
;						(else (error "heads differ: " (list (rcar rl) (car l))))))
;				((9 10) ; set a random element
;					(if (= len 0)
;						(list-test rst rl l len)
;						(lets 
;							((rst p (rand rst len))
;							 (rst v (rand rst 10000)))
;							(print* (list "L[" p "] = " v))
;							(list-test rst (rset rl p v) (lset l p v) len))))
;				((11) ; map increment
;					(list-test rst
;						(rmap (lambda (x) (+ x 1)) rl)
;						(map (lambda (x) (+ x 1)) l)
;						len))
;				((12) ; fold
;					(if (= (fold - 0 l) (rfold - 0 rl))
;						(list-test rst rl l len)
;						(error "folds fail at len " len)))
;				((13) ; foldr
;					(if (= (foldr - 0 l) (rfoldr - 0 rl))
;						(list-test rst rl l len)
;						(error "foldrs fail at len " len)))
;				((14) ; cross convert
;					(list-test rst
;						(list->rlist l)
;						(rlist->list rl) len))
;				((15) ; iter test
;					(if (equal? (fold - 0 l) (lfold - 0 (riter rl)))
;						(list-test rst rl l len)
;						(error "riter fails at len " len)))
;				((16) ; iterr test
;					(if (equal? (foldr - 0 l) (lfoldr - 0 (riterr rl)))
;						(list-test rst rl l len)
;						(error "riterr fails at len " len)))
;				((17)
;					(if (= (rlen rl) len)
;						(list-test rst rl l len)
;						(error "length fail: " (list 'got (rlen rl) 'for len))))
;				(else ; check a random element
;					(if (> len 0)
;						(lets ((rst p (rand rst len)))
;							(if (eq? (rget rl p 'nan) (lref l p))
;								(list-test rst rl l len)
;								(error "elems differ: " p)))
;						(list-test rst rl l len))))))
;
;	(define (test-ops)
;		(list-test (time 1) null null 0))
;
;
;	;; uncomment to run torture test
;	 (test-ops)
;)
;
;;;; iterators vs direct walks: direct around 40% faster
;;(import lib-lazy)
;;(import lib-rlist)
;;(define lst (list->rlist (iota 0 1 100000)))
;;(define op
;;	;(lambda (rl) (rfold (lambda (a b) a) 42 rl)) ; direct, 6.0s
;;	(lambda (rl) (lfold (lambda (a b) a) 42 (riter rl))) ; iterated, 10.7s
;;	)
;;(for-each (lambda (n) (print n) (op lst)) (iota 0 1 300))
;
